home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / charplot.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  5.5 KB  |  161 lines
  1. ;;;; "charplot.scm", plotting on character devices for Scheme
  2. ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'sort)
  21. (require 'printf)
  22.  
  23. (define charplot:rows 24)
  24. (define charplot:columns (output-port-width (current-output-port)))
  25.  
  26. (define charplot:xborder #\_)
  27. (define charplot:yborder #\|)
  28. (define charplot:xaxchar #\-)
  29. (define charplot:yaxchar #\:)
  30. (define charplot:curve1 #\*)
  31. (define charplot:xtick #\.)
  32.  
  33. (define charplot:height (- charplot:rows 5))
  34. (define charplot:width (- charplot:columns 15))
  35.  
  36. (define (charplot:printn! n char)
  37.   (cond ((positive? n)
  38.      (write-char char)
  39.      (charplot:printn! (+ n -1) char))))
  40.  
  41. (define (charplot:center-print! str width)
  42.   (let ((lpad (quotient (- width (string-length str)) 2)))
  43.     (charplot:printn! lpad #\ )
  44.     (display str)
  45.     (charplot:printn! (- width (+ (string-length  str) lpad)) #\ )))
  46.  
  47. (define (charplot:number->string x)
  48.   (sprintf #f "%g" x))
  49.  
  50. (define (scale-it z scale)
  51.   (if (and (exact? z) (integer? z))
  52.       (quotient (* z (car scale)) (cadr scale))
  53.       (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
  54.  
  55. (define (find-scale isize delta)
  56.   (if (inexact? delta) (set! isize (exact->inexact isize)))
  57.   (do ((d 1 (* d 10)))
  58.       ((<= delta isize)
  59.        (do ((n 1 (* n 10)))
  60.        ((>= (* delta 10) isize)
  61.         (list (* n (cond ((< (* delta 8) isize) 8)
  62.                  ((< (* delta 6) isize) 6)
  63.                  ((< (* delta 5) isize) 5)
  64.                  ((< (* delta 4) isize) 4)
  65.                  ((< (* delta 3) isize) 3)
  66.                  ((< (* delta 2) isize) 2)
  67.                  (else 1)))
  68.           d))
  69.      (set! delta (* delta 10))))
  70.     (set! isize (* isize 10))))
  71.  
  72. (define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
  73.   (define xaxis (- (scale-it ymin yscale)))
  74.   (define yaxis (- (scale-it xmin xscale)))
  75.   (charplot:center-print! ylabel 11)
  76.   (charplot:printn! (+ charplot:width 1) charplot:xborder)
  77.   (newline)
  78.   (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y))
  79.                        (< (car x) (car y))
  80.                        (> (cdr x) (cdr y))))))
  81.   (do ((ht (- charplot:height 1) (- ht 1)))
  82.       ((negative? ht))
  83.     (let ((a (make-string (+ charplot:width 1)
  84.               (if (= ht xaxis) charplot:xaxchar #\ )))
  85.       (ystep (if (= 1 (gcd (car yscale) 3)) 2 3)))
  86.       (string-set! a charplot:width charplot:yborder)
  87.       (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar))
  88.       (do ()
  89.       ((or (null? data) (not (>= (cdar data) ht))))
  90.     (string-set! a (caar data) charplot:curve1)
  91.     (set! data (cdr data)))
  92.       (if (zero? (modulo (- ht xaxis) ystep))
  93.       (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale))
  94.                         (car yscale))))
  95.          (l (string-length v)))
  96.         (if (> l 10)
  97.         (display (substring v 0 10))
  98.         (begin
  99.           (charplot:printn! (- 10 l) #\ )
  100.           (display v)))
  101.         (display charplot:yborder)
  102.         (display charplot:xaxchar))
  103.       (begin
  104.         (charplot:printn! 10 #\ )
  105.         (display charplot:yborder)
  106.         (display #\ )))
  107.       (display a) (newline)))
  108.   (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12))
  109.      (xstep/2 (quotient (- xstep 2) 2))
  110.      (fudge (modulo yaxis xstep)))
  111.     (charplot:printn! 10 #\ ) (display charplot:yborder)
  112.     (charplot:printn! (+ 1 fudge) charplot:xborder)
  113.     (display charplot:yaxchar)
  114.     (do ((i fudge (+ i xstep)))
  115.     ((> (+ i xstep) charplot:width)
  116.      (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep)
  117.                charplot:xborder))
  118.       (charplot:printn! xstep/2 charplot:xborder)
  119.       (display charplot:xtick)
  120.       (charplot:printn! xstep/2 charplot:xborder)
  121.       (display charplot:yaxchar))
  122.     (display charplot:yborder) (newline)
  123.     (charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
  124.     (do ((i fudge (+ i xstep)))
  125.     ((> (+ i xstep) charplot:width))
  126.       (charplot:center-print! (charplot:number->string
  127.                    (/ (* (- i yaxis) (cadr xscale))
  128.                   (car xscale)))
  129.                   xstep))
  130.     (newline)))
  131.  
  132. (define (charplot:plot! data xlabel ylabel)
  133.   (cond ((array? data)
  134.      (set! data (map (lambda (lst) (cons (car lst) (cadr lst)))
  135.              (array->list data)))))
  136.   (let* ((xmax (apply max (map car data)))
  137.      (xmin (apply min (map car data)))
  138.      (xscale (find-scale charplot:width (- xmax xmin)))
  139.      (ymax (apply max (map cdr data)))
  140.      (ymin (apply min (map cdr data)))
  141.      (yscale (find-scale charplot:height (- ymax ymin)))
  142.      (ixmin (scale-it xmin xscale))
  143.      (iymin (scale-it ymin yscale)))
  144.     (charplot:iplot! (map (lambda (p)
  145.                 (cons (- (scale-it (car p) xscale) ixmin)
  146.                   (- (scale-it (cdr p) yscale) iymin)))
  147.               data)
  148.              xlabel ylabel xmin xscale ymin yscale)))
  149.  
  150. (define (plot-function func vlo vhi . npts)
  151.   (set! npts (if (null? npts) 100 (car npts)))
  152.   (let ((dats (make-array 0.0 npts 2)))
  153.     (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts)
  154.               (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts)))))
  155.     (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts)
  156.         func
  157.         (make-shared-array dats (lambda (idx) (list idx 0)) npts))
  158.     (charplot:plot! dats "" "")))
  159.  
  160. (define plot! charplot:plot!)
  161.